Optional Dorothy.f
\ true constant [debug]

{
issues:
   inference cannot work inside macros since they are really just defered strings.
   only the top of the hint stack matters.
   you can't use static-style methods in methods because of the automatic compilation of THIS before matching dorothy expressions.

notes:
  constructor and destructor are not used - thinking of getting rid of them, so I won't use them for now.
  important coding convention: all dorothy words and methods that are not static-style take an object of the word's type at the top of the stack.
  added delegates instead of interfaces for now. it's a hack.
    the usage is:
    type: <name>
      delegate <whatever>
    end-type
    :NONAME ... ; >DELEGATE <type> <delegate>
    the limit to the delegates you can add per type is 16.

done:
   fields and constrefs
   pointers and refs
   word name hint
   assumption ( this ) hint
   methods
   collections - arrays, lists
   >< - override dorothy on a word
   SEE lets you see methods

todo:
   locals
   extend SEE, LOCATE, and EDIT to find a parent's method automatically

}

include Tools.f
include Heap.f


#USER
CELL +USER (this)
TO #USER



0 value (type)   \ Current type's XT, changes with each last keyword parsed, reset at beginning of each call to FATHOM to top of hint stack
                 \ will be the target's ancestor type (whatever word matched topmost ancestor of target)
0 value targettype>   \ body of the target type - this will be its actual type, picked up by compiling words.

string: combo
0 value working   here to working 256 /allot
32 stack: hints     \ Inference stack, XT's of types
 0 hints push
0 value with?    \ Counter - if 0 then we are not in "with" mode.
true value dorothy  \ enable/disable dorothy interpreter
0 value defining-dorothy-word?
0 value to?    \ set to true when FATHOMing the predicate of TO
0 value pointer-manip   \ holds xt of pointer for predicate of TO
0 value ref-manip
0 value remaining
0 value defining-method?

\ 16 stack: workings
\ : +working  working  workings  push  256 allocate drop to working ;
\ : -working  working free drop   workings pop  to working ;

: ?literal  state @ if postpone literal then ;

OPTIMIZING-COMPILER open-package
public : ?uncompile  state @ if uncompile else drop then ;
end-package

: compile  0< if compile, else execute then ;

: ?compile   state @ if compile else drop execute then ;

: at-col    ( n col -- )
   get-xy nip at-xy ;

: +working ;
: -working ;

: type>  ( -- addr ) targettype> ; \ (type) >body ;


: /SPLIT  ( a m b n -- b n a m-n )  DUP >R  2SWAP  R> - ;

: keyword   ( addr c -- remaining c  keyword c )
   2dup [char] . scan /split 2swap 1 /string 2swap ;

: is-expression?
   keyword 0> nip swap 0> and nip ;

: last-keyword?  remaining 1 < ;

: hint   ( -- xt )
   hints top ;

: any.<< ( -- )
   1 +to with?
   type> body> hints push
   state @ if
      [+asm]
         (this) [u] push
         ebx  (this) [u]  mov
         pop(ebx)
      [-asm]
   else
      (this) !
   then ; immediate

: >>  ( -- )
   -1 +to with?
   hints discard
   state @ if
      [+asm]
         (this) [u] pop
      [-asm]
   then ; immediate


{
check if the target was this and the with stack is > 0 - if so, and hint matches the word's type, compile fast method
}
: (method)
   with? 0>  dup . target> &of (this) =  dup . and   hint  type> body> =  dup . and  if
      r>  @  -1 ?compile
      ?( Compiled a fast method )
   else
      postpone any.<<
      r>  @  -1 ?compile
      postpone >>
   then ;


: target.ofs ;
: target.val ;
: target.type   cell+ ;
: target.count   cell+ cell+ ;


: typedef.size   ;
: typedef.parent  cell+ ;
: typedef.typesize cell+ cell+ ;

: sizeof   typedef.size @ ;



\ -- Target flavors --
\ Targets can be:
\  this
\  local          addr , type , count , dynamic? ,
\  ref            addr , type , count ,
\  constref       addr , type , count ,
\  type.field     ofs , type , count ,
\  type.pointer   ofs , type , count ,
\  type           size , parent , type-size , constructor , destructor , ...


0 value target>

: !target
   dup to target> ;

: (typedef)  r>      dup body> to (type)
                     working count is-expression? if drop exit then  \ Enables casting
                     state @ if postpone literal then ;

: (ref)   r>         !target dup target.type @ body> to (type)
                     to? last-keyword? and if body> to ref-manip exit then  \ because of TO-POINTER
                     state @ if postpone literal postpone @ else @ then ;

: (constref)   r>    !target dup target.type @ body> to (type)
                     @ state @ if postpone literal then ;

: (field)   r>       !target dup target.type @ body> to (type)
                     @ state @ if postpone literal postpone + else + then ;

: (pointer)   r>     !target dup target.type @ body> to (type)
                     to? last-keyword? and if body> to pointer-manip exit then \ Pointer xt will be retrieved again
                     @ state @ if postpone literal postpone + postpone @ else + @ then ;

: this               &of (this) !target
                     state @ if postpone (this) postpone @ else (this) @ then  ; immediate

: is-a-type?   ( addr c -- flag )
   (find) if
      parent ['] (typedef) =
   else false then ;

\ -- Parser --

: .append   2swap combo place " ." combo append combo append combo count ;

: .prepend  2swap .append ;

\ prepend keyword with current type
: qualify  ( keyword c type-xt -- word c )
   >name count .prepend ;

\ -- Dorothy interpreter --

\ try qualifying with current type and then its ancestors
\  if none is found, try just looking up the keyword
: determine  ( keyword c -- xt n found-type-xt )
   locals| c temp |
   (type) dup >body to targettype>  begin
      dup 0= over 0< or if
         drop
         temp c is-known?   ?dup  ( xt true true | false ) if 0 exit then
         123 throw  \ probably a number
      then
      temp c third qualify
      [defined] [debug] [if] bold .s  60 at-col  2dup type space normal [then]
      is-known? ?dup 0= while
      2drop >body typedef.parent @ body>
   repeat
   rot ;

: lookup
   is-known? 0= if drop drop 0 then ;

: descendent-or-equal?   ( ancestor typedef -- flag )
   begin dup while
      2dup = ?dup if nip nip exit then
      typedef.parent @
   repeat
   nip ;

0 value implicit?  \ gives ?THIS the final if it should compile THIS or not into the def

-? 0 value xt
: ?this
   \ first keyword: determine type; if it's HINT or an ancestor, and WITH? > 0, and the keyword is not a method, compile THIS
   with? if
      2dup keyword 2nip determine swap if
         hint  >body swap >body    descendent-or-equal? if
            \ dup parent ['] (typedef) <> swap
            [defined] [debug] [if] ." Implicit THIS check " [then]
            parent ['] (method) <> implicit? and if postpone this then
            exit
         then
      else
         drop
      then
      drop
   then ;

: (fathom)
   with? to implicit?
   hint to (type)
   ?this
   begin dup 0> while
      keyword 2swap  dup to remaining  2>r determine drop ?compile  2r>
   repeat  2drop ;

: fathom  ( c-addr len -- true | c-addr len false )
   working place working count
   ['] (fathom) catch ?dup if
      dup 123 <> if ." FATHOM THREW UP: " . else drop then
      false
   else
      true
   then
   ;

\ : infer?
\    with?  defining-dorothy-word?  or  ;


: dorothy-engine
   fathom ?exit
   UNKNOWN-TOKEN ;

: !type
   dup to (type) >body to targettype> ;

: ?>type
   2dup working place
   2dup is-expression? if
      2dup keyword 2nip lookup ?dup if !type then
   else
      with? if
         fathom not exit
      then
   then
   true
   ;

: dorothy-interpreter
   ?>type if word-interpreter then ;

: dorothy-compiler
   ?>type if  word-compiler  then ;

: dorothy-INTERPRETING ( -- flag )
   BEGIN
      STATE @ 0= WHILE
      BL WORD DUP C@ WHILE
      COUNT dorothy-INTERPRETER ?STACK
   REPEAT 0<> ELSE 0 THEN ;

: dorothy-COMPILING ( -- flag )
   BEGIN
      STATE @ WHILE
      BL WORD DUP C@ WHILE
      COUNT dorothy-COMPILER ?STACK
   REPEAT 0<> ELSE 0 THEN ;


\ -- Delegates -- in place of interfaces for now

\ to be used directly after type declarations (the TYPE: line)
\  structure:
\   typedef offset ,
: delegate ( struct -- <name> struct )
   locals| struct |
   create

   struct typedef.typesize @ ,
   cell struct typedef.typesize +!
   struct

   does> ( ... typedef -- )
      @ + @ execute ;

: >delegate  ( xt -- <type> <delegate> )
   ' >body ' >body @ + ! ;

\ -- Defining types --

: Typedef:   header postpone (typedef) immediate ;

typedef: typedef  0 , 0 , 5 cells ,
typedef: target   0 , 0 , 4 cells ,

Typedef: any  0 , 0 , 3 cells , 16 cells /allot
any
delegate construct  :noname   drop ; >delegate any construct
delegate destruct   :noname   drop ; >delegate any destruct
drop

0 value last-size

: fieldarray ( struct type n -- <name> struct )
   locals| n type struct |
   " header " pad place
   struct body> >name count bl parse .append pad append
   pad count evaluate  immediate
   postpone (field)
   struct @ dup to last-size ,
   type ,
   n ,
   type sizeof n * struct +!
   struct  ;

: field   1 fieldarray ;



\ ---------------------------------------- BEGIN API ---------------------------------------------


: Extend:   ( type -- <name> )
   Typedef: here swap dup dup sizeof , , typedef.typesize @+ dup , here >r dup allot r> swap move  16 cells /allot ;

: Type:  any extend: ;

: End-type   drop ;

: reopen  ' >body ;
: goback   last-size over ! ;
: skip   @ over +! ;
: nskip   over +! ;
: union  0 over ! ;


\ -- Field base-types --

aka 2@ (2@)

Type:  int   cell nskip  end-type
macro: int.@  @ ;
macro: int.!  ! ;
macro: int.+!  +! ;
macro: int.clear   off ;
macro: int.on   on ;
macro: int.off   off ;
macro: int.?    ? ;
macro: int.2@   (2@) swap ;
macro: int.3@   @+ swap @+ swap @ ;

Type:  short   2 nskip  end-type
macro: short.@  h@ ;
macro: short.!  h! ;
macro: short.+!  h+! ;
macro: short.clear  0 swap h! ;
macro: short.on   -1 swap h! ;
macro: short.off   short.clear ;
macro: short.?    h@ . ;
macro: short.2@   2h@ ;
macro: short.2!   2h! ;

Type:  ushort   2 nskip  end-type
macro: ushort.@  w@ ;
macro: ushort.!  w! ;
macro: ushort.+!  w+! ;
macro: ushort.clear  0 swap w! ;
macro: ushort.on   -1 swap w! ;
macro: ushort.off   ushort.clear ;
macro: ushort.?    w@ . ;
\ macro: ushort.2@   2w@ ;

Type:  byte  1 nskip  end-type
macro: byte.@  c@ ;
macro: byte.!  c! ;
macro: byte.+!  c+! ;
macro: byte.clear  0 swap c! ;
macro: byte.on   -1 swap c! ;
macro: byte.off   byte.clear ;
macro: byte.?    c@ . ;
macro: byte.2@    c@+ swap c@ ;


\ -- Refs --

: any.ref  ( object -- <name> )
   header postpone (ref) immediate
   , type> , 1 , ;

: any.ref[]  ( n addr -- <name> )
   header postpone (ref) immediate
   , type> , , ;

\ -- Constrefs --

: any.const  ( object -- <name> )
   header postpone (constref) immediate
   , type> , 1 , ;

: any.make  ( -- <name> )
   here type> sizeof  /allot any.const ;

: any.make[]  ( n -- <name> )
   header postpone (constref) immediate
   here cell+ cell+ cell+ , type> , dup ,
   type> sizeof * /allot ;

: lastobject  lastbody @ ;

\ -- Fields --

: any.field  ( struct -- <name> struct )
   type> field ;

: any.field[]  ( struct n -- <name> struct )
   type> swap fieldarray ;

: any.skip
   type> skip ;

\ -- Pointers --

: pointer[]
   locals| n type struct |
   " header " pad place
   struct body> >name count bl parse .append pad append
   pad count evaluate  immediate
   postpone (pointer)  struct @ , type , n ,
   cell struct +!
    struct ;

: pointer
   1 pointer[] ;

: any.pointer
   type> pointer ;

: any.pointer[]  ( struct n -- <name> struct )
   type>  swap pointer[] ;

\ -- Ability to modify refs and pointers --

: (to-ref)   >body state @ if  postpone literal  postpone !  exit  then   ! ;
: (+to-ref)   >body state @ if  postpone literal  postpone +!  exit  then   +! ;
: (&of-ref)   >body state @ if  postpone literal  then  ;

: ?2drop  dup 0= if nip nip then ;

: to-ref ( xt -- flag )
   locals| xt |
   >in @ >r
   true to to?
   0 to ref-manip
   bl parse fathom  ?2drop  ref-manip parent ['] (ref) = and if
      ref-manip xt execute  r> drop  true
   else
      r> >in !  false
   then
   false to to? ;

: (to-pointer)   >body @  state @ if  postpone literal  postpone +  postpone !  exit  then   + ! ;
: (+to-pointer)   >body @  state @ if  postpone literal  postpone +  postpone +!  exit  then   + +! ;
: (&of-pointer)   >body @  state @ if  postpone literal  postpone +  exit  then   + ;

: ?'  bl parse (find) 0= if false then ;

: to-pointer ( xt -- flag )
   locals| xt |
   >in @ >r
   ?'  parent  ['] (value)  =  if  false r> >in ! exit then
   r@ >in !
   true to to?
   0 to pointer-manip
   bl parse fathom   ?2drop  pointer-manip parent ['] (pointer) =  and  if
      pointer-manip xt execute r> drop  true
   else
      r> >in ! false
   then
   false to to? ;


\ TODO: the order of the checks will depend on if the next word is an expression or not , following the same
\  rules as DOROTHY.compileR
-? : to ( n -- )
             ['] (to-pointer) to-pointer ?exit
   lvar-comp to-local ?exit
             to-value ?exit
             ['] (to-ref) to-ref ?exit
             1 'method ! ; immediate
-? : +to ( n -- )
             ['] (+to-pointer) to-pointer ?exit
   lvar-comp +to-local ?exit
             +to-value ?exit
             ['] (+to-ref) to-ref ?exit
             2 'method ! ; immediate
-? : &of ( -- addr )
             ['] (&of-pointer) to-pointer ?exit
   lvar-comp &of-local ?exit
             &of-value ?exit
             ['] (&of-ref) to-ref ?exit
             3 'method ! ; immediate


\ -- Put it all together --

0 value (topic)

: topic>   (topic) state @ if postpone literal then ; immediate


: ?dorothy-word
   locals| name |
   name count is-expression?
   dup if
      name count keyword 2nip is-a-type? dup
         if name count keyword 2nip (find) drop
         dup >body to (topic)
         hints push then   \ push the type onto the inference stack
      and
   then
   to defining-dorothy-word? ;

\ doing ' is impossible because an expression can expand to multiple words
{ : (') ( "name" -- xt )
   BL WORD  DUP C@ HUH?  FIND ?dup 0= if
      count ['] determine catch .s 0=
   then
   HUH? ; }


: (:)   : last @ ?dorothy-word ;

\ macros are a special case in that they work by evaluating the code as a string
\  so they need to push their type onto the inference stack when the macro is executed.
: (macro:)
   : immediate postpone (s") [char] ; string  \ compile code as string
   last @ ?dorothy-word
   hint " literal hints push evaluate ; " evaluate  \ compile the code to interpret it ( ; will discard the hint )
   hints discard ;

: (:noname)
   false to defining-dorothy-word?
   :noname   ;

: (;)
   0 to with?
   postpone ;
   defining-dorothy-word? if hints discard then
   false to defining-dorothy-word?
   false to defining-method?
   hints clear-stack
   0 hints push
   ; immediate


: -evaluate
   false to dorothy  evaluate  true to dorothy ;


: method:
   true to defining-method?
   header postpone (method) immediate
   here 0 ,
   last @ >r  (:noname)  r> ?dorothy-word     1 to with?   swap !  ;

: >< ' compile, ; immediate

-? : see
   ' dup parent ['] (method) = if
      >code $b + dasm
   else
      >code dasm
   then ;


: -dorothy  false to dorothy ;
: +dorothy  true to dorothy ;



\ copy the contents of an object to another object of the same type
: any.copy   ( object object -- )
   state @ if
      " [ type> sizeof ] literal move " -evaluate
   else
      type> sizeof move
   then ; immediate

: any.new
   state @ if
      " [ type> sizeof ] literal chunk dup [ type> ] literal construct " -evaluate
   else
      type> sizeof chunk dup type> construct
   then ; immediate

: any.dispose
   state @ if
      " dup [ type> ] literal destruct recycle " -evaluate
   else
      dup type> destruct recycle
   then ; immediate

: anyp*
   state @ if
      " [ type> sizeof ] literal * " -evaluate
   else
      type> sizeof *
   then ; immediate

\ Used to compile a routine from the nearest ancestor; makes it possible to extend any routine.
: super
   (type) >body typedef.parent @ body> to (type) ; immediate

: go
  "  -? aka (:) : " evaluate
  \ "  -? aka (macro:) macro: " evaluate
  "  -? aka (:noname) :noname " evaluate
  "  -? aka (;) ; immediate " evaluate
  ['] dorothy-engine is not-defined
  ['] dorothy-interpreting is interpreting
  ['] dorothy-compiling is compiling
;


:prune
   ['] UNKNOWN-TOKEN is not-defined
   ['] (interpreting) is interpreting
   ['] (compiling) is compiling ;


go

include collections.f

[defined] [debug] [if] include tests.f [then]
